Giga Games 1/Giga Games.iso/net/vir_real/veos/part10

Internet Message Format | 1993-06-20 | 72.3 KB

Path: wupost!decwrl!decwrl!vixie!vixie!not-for-mail
From: [e-mail] (Geoffery Coco)
Newsgroups: comp.sources.unix
Subject: v26i193: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part10/16
Date: 25 Apr 1993 23:15:22 -0700
Organization: Vixie Home Computing
Lines: 2553
Sender: [e-mail]
Approved: [e-mail]
Message-ID: <1rfulq$[e-mail]>
NNTP-Posting-Host: efficacy.home.vix.com

Submitted-By: [e-mail] (Geoffery Coco)
Posting-Number: Volume 26, Issue 193
Archive-Name: veos-2.0/part10

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 10 (of 16)."
# Contents:  src/kernel_current/shell/xv_native.c
#   src/xlisp/xcore/c/xleval.c src/xlisp/xcore/c/xlftab.c
# Wrapped by [e-mail] on Sun Apr 25 23:10:42 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/kernel_current/shell/xv_native.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/kernel_current/shell/xv_native.c'\"
else
echo shar: Extracting \"'src/kernel_current/shell/xv_native.c'\" \(24300 characters\)
sed "s/^X//" >'src/kernel_current/shell/xv_native.c' <<'END_OF_FILE'
X/****************************************************************************************
X *                                            *
X * file: xv_native.c                                    *
X *                                            *
X * the xlisp wrappers for the VEOS native prims.                    *
X *                                            *
X * creation: December, 1991                                *
X *                                            *
X *                                            *
X * by Geoffrey P. Coco at the HITLab, Seattle.                          *
X *                                            *
X ****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Copyright (C) 1992  Geoffrey P. Coco, Human Interface Technology Lab, Seattle    *
X ****************************************************************************************/
X
X
X
X/****************************************************************************************
X                      Preliminaries
X ****************************************************************************************/
X
X#include <math.h>
X#include "xlisp.h"
X
X/* VEOS definitions: */
X#include "kernel.h"
X
X#define DEFINE_NATIVE_GLOBS
X#include "xv_native.h"
X#undef DEFINE_NATIVE_GLOBS
X
X/****************************************************************************************/
X
XTVeosErr Native_MessageToLSpace();
Xvoid Native_ShowMatchArgs();
Xvoid Native_ShowSite();
XTVeosErr Native_XCopySiteMatches();
XTVeosErr Native_XRemoveSiteMatches();
XTVeosErr Native_XInsertEltAtSite();
Xvoid Native_NextMsg();
XTVeosErr Native_DoThrow();
X
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X                 Veos Primitive Wrappers
X ****************************************************************************************/
X
X
X/****************************************************************************************/
XLVAL Native_Init()
X{
X    LVAL         pXReturn;
X    int        iPort;
X    TVeosErr    iErr;
X
X    xlsave1(pXReturn);
X
X    if (!moreargs())
X    iPort = TALK_BOGUS_FD;
X    else
X    iPort = getfixnum(xlgafixnum());
X
X    xllastarg();
X
X
X    /** invoke veos kernel inialization **/
X
X    iErr = Kernel_Init(iPort, Native_MessageToLSpace);
X    if (iErr == VEOS_SUCCESS) {
X
X
X    /** create a lisp based inspace for messages **/
X
X    s_InSpace = xlenter("VEOS_INSPACE");
X    setvalue(s_InSpace, NIL);
X    NATIVE_INSPACE = &getvalue(s_InSpace);
X
X
X    /** create keyword symbols for nancy prims **/
X
X    k_TestTime = xlenter(":TEST-TIME"); /* use with copy only */
X    k_Freq = xlenter(":FREQ");         /* use with copy, put or get */
X
X
X    /** setup invariant matcher settings in global param blocks **/
X
X    Native_InitMatcherPBs();
X
X
X    /** make a uid return value to signify success **/
X
X
X    Uid2XVect(&IDENT_ADDR, &pXReturn);
X    }
X
X
X    xlpop();
X
X
X    return(pXReturn);
X
X    }  /* Native_Init */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XLVAL Native_Close()
X{
X    if (!KERNEL_INIT)
X    Native_TrapErr(NATIVE_NOKERNEL, nil);
X
X    xllastarg();
X
X    Kernel_Shutdown();
X
X    return(true);
X
X    } /* Native_Close */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XLVAL Native_Task()
X{
X#ifndef OPTIMAL
X    if (!KERNEL_INIT)
X    Native_TrapErr(NATIVE_NOKERNEL, nil);
X
X    xllastarg();
X#endif
X
X    /** talk will call our message handler and stuff the inspace **/
X
X    Kernel_SystemTask();
X
X
X    return(true);
X
X    } /* Native_Task */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XLVAL Native_Put()
X{
X    TVeosErr    iErr;
X    TTimeStamp    tNow;
X
X#ifndef OPTIMAL
X    if (!KERNEL_INIT)
X    Native_TrapErr(NATIVE_NOKERNEL, nil);
X#endif
X
X
X
X    /** get mandatory data argument **/
X
X    native_putPB.pXReplaceElt = xlgetarg();
X
X
X
X    /** get pattern from xlisp args **/
X
X    iErr = Native_GetPatternArg(&native_putPB.pPatGr, NANCY_ReplaceMatch);
X    if (iErr != VEOS_SUCCESS)
X    Native_TrapErr(iErr, nil);
X
X
X    /** get optional frequency argument **/
X
X    NATIVE_FREQ_ARG(native_putPB.iFreqFlag);
X
X
X    /** set the data time-stamp **/
X
X    GET_TIME(tNow);
X    native_putPB.pStampTime = &tNow;
X
X
X    /** dispatch the matcher **/
X
X    xlsave1(native_putPB.pXResult);
X
X    Native_XMandR(&native_putPB);
X
X    xlpop();
X
X
X
X    /** clean up **/
X
X    Nancy_DisposeGrouple(native_putPB.pPatGr);
X
X
X
X    return (native_putPB.pXResult);
X
X    } /* Native_Put */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
XLVAL Native_Get()
X{
X    TVeosErr    iErr;
X
X#ifndef OPTIMAL
X    if (!KERNEL_INIT)
X    Native_TrapErr(NATIVE_NOKERNEL, nil);
X#endif
X
X    /** get pattern from xlisp args **/
X
X    iErr = Native_GetPatternArg(&native_getPB.pPatGr, NANCY_RemoveMatch);
X    if (iErr != VEOS_SUCCESS)
X    Native_TrapErr(iErr, nil);
X
X
X    /** get optional frequency argument **/
X
X    NATIVE_FREQ_ARG(native_getPB.iFreqFlag);
X
X
X    /** dispatch the matcher **/
X
X    xlsave1(native_getPB.pXResult);
X
X    Native_XMandR(&native_getPB);
X
X    xlpop();
X
X
X    /** clean up **/
X
X    Nancy_DisposeGrouple(native_getPB.pPatGr);
X
X
X
X    return (native_getPB.pXResult);
X
X    } /* Native_Get */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
XLVAL Native_Copy()
X{
X    TVeosErr    iErr;
X    TTimeStamp    tTest;
X
X#ifndef OPTIMAL
X    if (!KERNEL_INIT)
X    Native_TrapErr(NATIVE_NOKERNEL, nil);
X#endif
X
X
X
X    /** get pattern from xlisp args **/
X
X    iErr = Native_GetPatternArg(&native_copyPB.pPatGr, NANCY_CopyMatch);
X    if (iErr != VEOS_SUCCESS)
X    Native_TrapErr(iErr, nil);
X
X
X    /** look for optional time-stamp-test **/
X
X    NATIVE_TIME_ARG(native_copyPB.pTestTime, tTest);
X
X
X    /** get optional frequency argument **/
X
X    NATIVE_FREQ_ARG(native_copyPB.iFreqFlag);
X
X
X    /** dispatch the matcher **/
X
X    xlsave1(native_copyPB.pXResult);
X
X    Native_XMandR(&native_copyPB);
X
X    xlpop();
X
X
X    /** clean up **/
X
X    Nancy_DisposeGrouple(native_copyPB.pPatGr);
X
X
X
X    return (native_copyPB.pXResult);
X
X    } /* Native_Copy */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
XLVAL Native_Throw()
X{
X    LVAL    pXData, pXDests;
X    TVeosErr    iErr;
X
X#ifndef OPTIMAL
X    if (!KERNEL_INIT)
X    Native_TrapErr(NATIVE_NOKERNEL, nil);
X#endif
X
X    /** get dests argument **/
X
X    pXDests = xlgalist();
X
X
X    /** get data argument **/
X
X    pXData = xlgetarg();
X
X#ifndef OPTIMAL
X    xllastarg();
X#endif
X
X    iErr = Native_DoThrow(pXDests, pXData);
X
X    return(iErr == VEOS_SUCCESS ? true : NIL);
X
X    } /* Native_Throw */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XLVAL Native_Catch()
X{
X    LVAL    pSave;
X    TPElt    pElt;
X
X#ifndef OPTIMAL
X    if (!KERNEL_INIT)
X    Native_TrapErr(NATIVE_NOKERNEL, nil);
X
X    xllastarg();
X#endif
X
X    Native_NextMsg(&pSave);
X
X    return (pSave);
X
X    } /* Native_Catch */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XLVAL Native_MinTime()
X{
X    TF2L    fTrans;
X
X    /* guaranteed to be earlier than any system time */
X
X    fTrans.u.l = NANCY_MINTIME;
X
X    return(cvflonum(fTrans.u.f));
X
X    }  /* Native_MinTime */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XLVAL Native_NoSignals()
X{
X    SIG_ENABLE = FALSE;
X
X    return(true);
X
X    }  /* Native_NoSignals */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XLVAL Native_Bugs()
X{
X    LVAL    pXModule;
X    char    *sName;
X
X    pXModule = xlgastring();
X    sName = (char *) getstring(pXModule);
X
X    if (strcmp(sName, "talk") == 0)
X    TALK_BUGS = TALK_BUGS ? FALSE : TRUE;
X
X    else if (strcmp(sName, "nancy") == 0)
X    NANCY_BUGS = NANCY_BUGS ? FALSE : TRUE;
X
X    else if (strcmp(sName, "shell") == 0)
X    SHELL_BUGS = SHELL_BUGS ? FALSE : TRUE;
X
X    return(true);
X
X    }  /* Native_Bugs */
X/****************************************************************************************/
X
Xextern int iEvals;
X
X/****************************************************************************************/
XLVAL Native_Zoot()
X{
X    static int    iAlreadySeen = 0;
X    int        iSinceLast;
X
X    iSinceLast = iEvals - iAlreadySeen;
X    iAlreadySeen = iEvals;
X
X    return(cvfixnum(iSinceLast));
X
X    } /* Native_Zoot */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X             The Beuractratic Linkage Between Veos and XLISP
X ****************************************************************************************/
X
X
X/****************************************************************************************/
XTVeosErr Shell_LoadNativePrims()
X{
X#define VEOS_NATIVE_LOAD
X#include "xv_native_prims.h"
X#undef VEOS_NATIVE_LOAD
X
X    return(VEOS_SUCCESS);
X    }
X/****************************************************************************************/
X
X
X/****************************************************************************************/
XTVeosErr Shell_BailOut(sErr)
X    char        *sErr;
X{
X
X    xlfatal(sErr);
X
X    /** not reached **/
X
X    return(VEOS_SUCCESS);
X
X    } /* Shell_BailOut */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X             The Sticky Goo Just Beneath the Wrappers
X ****************************************************************************************/
X
X
X/****************************************************************************************/
XTVeosErr Native_InitMatcherPBs()
X{
X    /** vget settings **/
X
X    native_getPB.pSrcGr = WORK_SPACE;
X    native_getPB.iDestroyFlag = NANCY_RemoveMatch;
X    native_getPB.pXReplaceElt = nil;
X    native_getPB.pStampTime = nil;
X    native_getPB.pTestTime = nil;
X
X    /** vcopy settings **/
X
X    native_copyPB.pSrcGr = WORK_SPACE;
X    native_copyPB.iDestroyFlag = NANCY_CopyMatch;
X    native_copyPB.pXReplaceElt = nil;
X    native_copyPB.pStampTime = nil;
X
X    /** vput settings **/
X
X    native_putPB.pSrcGr = WORK_SPACE;
X    native_putPB.iDestroyFlag = NANCY_ReplaceMatch;
X    native_putPB.pTestTime = nil;
X
X
X    return(VEOS_SUCCESS);
X
X    } /* Native_InitMatcherPBs */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Native_DoThrow(pXDests, pXData)
X    LVAL    pXData, pXDests;
X{
X    TPUidNode    pDests;
X    TVeosErr    iErr;
X    TMsgRec    msgOut;
X
X
X    /** convert host/port vectors to talk uids **/
X
X    iErr = Native_XVectsToUids(pXDests, &pDests);
X    if (iErr != VEOS_SUCCESS) {
X    Native_TrapErr(iErr, pXDests);
X    }
X
X    /** convert data element to flat network format **/
X
X    iErr = Native_XEltToMsgRec(pXData, &msgOut);
X    if (iErr != VEOS_SUCCESS) {
X    Native_DisposeUids(pDests);
X    Native_TrapErr(iErr, pXData);
X    }
X
X    /** pass the flat message to veos kernel **/
X
X    iErr = Talk_SpeakToMany(pDests, &msgOut);
X
X
X    Native_DisposeUids(pDests);
X
X    return(iErr);
X
X    } /* Native_DoThrow */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
Xvoid Native_NextMsg(hMsg)
X    LVAL          *hMsg;
X{
X    *hMsg = NIL;
X
X    if (!null(*NATIVE_INSPACE)) {
X
X    /** get the oldest message **/
X
X    *hMsg = car(*NATIVE_INSPACE);
X
X    /** remove this msg from list immediately.
X     ** first cons cell in this list will thus be garbage collected.
X     ** pass back the new msg.
X     **/
X
X    *NATIVE_INSPACE = cdr(*NATIVE_INSPACE);
X    }
X    }
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Native_XMandR(pMandRPB)
X    TPXMandRRec        pMandRPB;
X{
X    TVeosErr        iErr;
X    TMatchRec        matchSpec;
X    TPReplaceRec    pSite, pSave;
X
X
X    /** Initialize the match record.
X     ** This record get passed through the entire match process.
X     ** The matcher uses to record sites for removal and insertion.
X     ** If the matcher returns success,
X     ** we then perform any destructive operations on the gspace.
X     **/
X
X    matchSpec.pPatGr = pMandRPB->pPatGr;
X    matchSpec.pSrcGr = pMandRPB->pSrcGr;
X    matchSpec.iDestroyFlag = pMandRPB->iDestroyFlag;
X    matchSpec.iFreqFlag = pMandRPB->iFreqFlag;
X    matchSpec.pReplaceList = nil;
X    matchSpec.pTouchList = nil;
X
X#ifndef OPTIMAL
X    if (NANCY_BUGS)
X    Native_ShowMatchArgs(pMandRPB);
X#endif
X
X    /************************************/
X
X    iErr = Nancy_MatchGrouple(&matchSpec);
X
X    /************************************/
X
X#ifndef OPTIMAL
X    if (NANCY_BUGS)
X    fprintf(stderr, "nancy %s: match %s.\n",
X        WHOAMI, iErr == VEOS_SUCCESS ? "succeeded" : "failed");
X#endif
X
X    /** Perform any destructive operations on the gspace.
X     ** These occur in on a per-site basis.
X     ** A site is:
X     **   an enclosing grouple,
X     **   a set of element intervals,
X     **   an element index at which to insert.
X     ** Sites are generated by the matcher during matching.
X     **/
X
X    /** perform destructive element retrieval
X     **/
X
X    switch (pMandRPB->iDestroyFlag) {
X
X    case NANCY_CopyMatch:
X    for (pSite = matchSpec.pReplaceList;
X         pSite && iErr == VEOS_SUCCESS;
X         pSite = pSite->pNext) {
X#ifndef OPTIMAL
X        if (NANCY_BUGS)
X        Native_ShowSite(pSite);
X#endif
X        iErr = Native_XCopySiteMatches(pSite, pMandRPB->pTestTime,
X                       &pMandRPB->pXResult);
X        }
X    break;
X
X    case NANCY_RemoveMatch:
X    for (pSite = matchSpec.pReplaceList;
X         pSite && iErr == VEOS_SUCCESS;
X         pSite = pSite->pNext) {
X
X#ifndef OPTIMAL
X        if (NANCY_BUGS)
X        Native_ShowSite(pSite);
X#endif
X        iErr = Native_XRemoveSiteMatches(pSite, pMandRPB->pTestTime,
X                         &pMandRPB->pXResult);
X        }
X    break;
X
X    case NANCY_ReplaceMatch:
X    for (pSite = matchSpec.pReplaceList;
X         pSite && iErr == VEOS_SUCCESS;
X         pSite = pSite->pNext) {
X
X#ifndef OPTIMAL
X        if (NANCY_BUGS)
X        Native_ShowSite(pSite);
X#endif
X        iErr = Native_XRemoveSiteMatches(pSite, pMandRPB->pTestTime,
X                         &pMandRPB->pXResult);
X        if (iErr == VEOS_SUCCESS)
X        iErr = Native_XInsertEltAtSite(pMandRPB->pXReplaceElt,
X                           pMandRPB->pStampTime, pSite);
X        }
X    break;
X
X    case NANCY_GimmeMatch:
X    iErr = NANCY_NotSupported;
X    break;
X
X    } /* switch */
X
X
X    /** perform destructive element time stamping
X     **/
X
X    if (pMandRPB->pStampTime) {
X
X    for (pSite = matchSpec.pTouchList;
X         pSite && iErr == VEOS_SUCCESS;
X         pSite = pSite->pNext) {
X#ifndef OPTIMAL
X        if (NANCY_BUGS)
X        Native_ShowSite(pSite);
X#endif
X        Native_TouchSiteMatches(pSite, *pMandRPB->pStampTime);
X
X        }
X    }
X
X    /** free all matcher memory (stays within veos kernel) **/
X
X    pSite = matchSpec.pReplaceList;
X    while (pSite) {
X    pSave = pSite;
X    pSite = pSite->pNext;
X    Shell_ReturnBlock(pSave, sizeof(TReplaceRec), "replace-bp");
X    }
X
X    pSite = matchSpec.pTouchList;
X    while (pSite) {
X    pSave = pSite;
X    pSite = pSite->pNext;
X    Shell_ReturnBlock(pSave, sizeof(TReplaceRec), "replace-bp");
X    }
X
X
X    if (iErr == VEOS_SUCCESS) {
X
X    /** check for successful insert (give caller appropriate feeback) **/
X
X    if (pMandRPB->iDestroyFlag == NANCY_ReplaceMatch &&
X        pMandRPB->pXResult == NIL)
X
X        pMandRPB->pXResult = true;
X    }
X
X#ifndef OPTIMAL
X    else {
X    if (NANCY_BUGS)
X        Nancy_TrapErr(iErr);
X    }
X#endif
X
X    return(iErr);
X
X    } /* Native_MatchAndReplace */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Native_XCopySiteMatches(pSite, pTestTime, hXResult)
X    TPReplaceRec    pSite;
X    TPTimeStamp        pTestTime;
X    LVAL        *hXResult;
X{
X    int            iZone, iToKill, iElt, iLeft, iRight;
X    LVAL        pXElt;
X    TPElt        pVElt;
X    TVeosErr        iErr;
X
X    xlsave1(pXElt);
X
X    /** convert outgoing data into supplanted language format.
X     ** lisp is the current control language
X     **/
X
X    if (pTestTime == nil) {
X
X    for (iZone = pSite->iZones - 1; iZone >= 0; iZone --) {
X        iLeft = pSite->pWipeList[iZone].iLeft;
X        iRight = pSite->pWipeList[iZone].iRight;
X        iToKill = iRight - iLeft + 1;
X
X#ifndef OPTIMAL
X        if (NANCY_BUGS) {
X        fprintf(stderr, "nancy %s: left: %d right: %d\n",
X            WHOAMI, iLeft, iRight);
X        }
X#endif
X        for (iElt = iRight, pVElt = &pSite->pEnviron->pEltList[iRight];
X         iElt >= iLeft;
X         iElt--, pVElt --) {
X
X        if (Native_VEltToXElt(pVElt, &pXElt) == VEOS_SUCCESS)
X
X            /** assume caller protected *hXResult **/
X            *hXResult = cons(pXElt, *hXResult);
X        }
X        }
X    }
X    else {
X
X    for (iZone = pSite->iZones - 1; iZone >= 0; iZone --) {
X        iLeft = pSite->pWipeList[iZone].iLeft;
X        iRight = pSite->pWipeList[iZone].iRight;
X        iToKill = iRight - iLeft + 1;
X
X#ifndef OPTIMAL
X        if (NANCY_BUGS) {
X        fprintf(stderr, "nancy %s: left: %d right: %d\n",
X            WHOAMI, iLeft, iRight);
X        }
X#endif
X
X        for (iElt = iRight, pVElt = &pSite->pEnviron->pEltList[iRight];
X         iElt >= iLeft;
X         iElt--, pVElt--) {
X
X        iErr = Native_NewVEltToXElt(pVElt, &pXElt, *pTestTime);
X        if (iErr == VEOS_SUCCESS) {
X
X            /** assume caller protected *hXResult **/
X            *hXResult = cons(pXElt, *hXResult);
X            }
X        /*
X        else if (iErr == NATIVE_STALE)
X            iErr = VEOS_SUCCESS;
X            */
X        }
X        }
X    }
X
X    xlpop();
X
X    return(VEOS_SUCCESS);
X
X    } /* Native_XCopySiteMatches */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Native_XRemoveSiteMatches(pSite, pTestTime, hXResult)
X    TPReplaceRec    pSite;
X    TPTimeStamp        pTestTime;
X    LVAL        *hXResult;
X{
X    int            iZone, iToKill, iElt, iLeft, iRight;
X    LVAL        pXElt;
X    TPElt        pVElt;
X
X    xlsave1(pXElt);
X
X    for (iZone = pSite->iZones - 1; iZone >= 0; iZone --) {
X    iLeft = pSite->pWipeList[iZone].iLeft;
X    iRight = pSite->pWipeList[iZone].iRight;
X    iToKill = iRight - iLeft + 1;
X
X    /** convert outgoing data into supplanted language format.
X     ** that format is xlisp, and in reverse order
X     **/
X
X    for (iElt = iRight, pVElt = &pSite->pEnviron->pEltList[iRight];
X         iElt >= iLeft;
X         iElt--, pVElt--) {
X
X        if (Native_VEltToXElt(pVElt, &pXElt) == VEOS_SUCCESS)
X
X        /** assume caller has protected *hXResult **/
X
X        *hXResult = cons(pXElt, *hXResult);
X        }
X
X    Nancy_DeleteElementsInGrouple(pSite->pEnviron,
X                      iLeft,
X                      iToKill);
X    }
X
X    xlpop();
X
X    return(VEOS_SUCCESS);
X
X    } /* Native_XRemoveSiteMatches */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Native_XInsertEltAtSite(pXReplaceElt, pStampTime, pSite)
X    LVAL        pXReplaceElt;
X    TPTimeStamp        pStampTime;
X    TPReplaceRec    pSite;
X{
X    TElt        localElt;
X    TVeosErr        iErr = VEOS_SUCCESS;
X
X    if (pSite->iInsertElt >= 0) {
X
X    localElt = NIL_ELT;
X
X    if (pStampTime)
X        iErr = Native_XEltToNewVElt(pXReplaceElt, &localElt, *pStampTime);
X    else
X        iErr = Native_XEltToVElt(pXReplaceElt, &localElt);
X
X    if (iErr == VEOS_SUCCESS) {
X
X        Nancy_NewElementsInGrouple(pSite->pEnviron, pSite->iInsertElt, 1,
X                       GR_unspecified, 0);
X        pSite->pEnviron->pEltList[pSite->iInsertElt] = localElt;
X        }
X    }
X
X    return(iErr);
X
X    } /* Native_XInsertEltAtSite */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Native_TouchSiteMatches(pSite, time)
X    TPReplaceRec    pSite;
X    TTimeStamp        time;
X{
X    int            iZone, iElt, iLeft, iRight;
X    TPElt        pVElt;
X
X    for (iZone = pSite->iZones - 1; iZone >= 0; iZone --) {
X
X    iLeft = pSite->pWipeList[iZone].iLeft;
X    iRight = pSite->pWipeList[iZone].iRight;
X
X    /** simply update time stamp of given elements **/
X
X    for (iElt = iRight, pVElt = &pSite->pEnviron->pEltList[iRight];
X         iElt >= iLeft;
X         iElt--, pVElt--)
X
X        pVElt->tLastMod = time;
X    }
X
X    return(VEOS_SUCCESS);
X
X    } /* Native_TouchSiteMatches */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Native_MessageToLSpace(pMsgRec)
X    TPMsgRec        pMsgRec;
X{
X    TVeosErr         iErr;
X    LVAL        pXElt, *hFinger;
X    int            iLen;
X    char        *pBuf;
X
X
X    xlsave1(pXElt);
X
X    /** return data to grouple form **/
X
X    pBuf = pMsgRec->sMessage;
X    iLen = 0;
X    iErr = Native_MessageToXElt(pBuf, &pXElt, &iLen);
X
X#ifndef OPTIMAL
X    if (TALK_BUGS) {
X    fprintf(stderr, "listen %s: results of message conversion, native: %d\n",
X        WHOAMI, iErr);
X    }
X#endif
X
X    if (iErr == VEOS_SUCCESS) {
X
X#ifndef OPTIMAL
X    if (TALK_BUGS) {
X        fprintf(stderr, "listen %s: element in message:\n", WHOAMI);
X
X        errprint(pXElt);
X        }
X#endif
X
X    /** append message to native inspace list **/
X
X    hFinger = NATIVE_INSPACE;
X    while (!null(*hFinger))
X        hFinger = &cdr(*hFinger);
X
X    *hFinger = cons(pXElt, NIL);
X    }
X
X    xlpop();
X
X    return(iErr);
X
X    } /* Native_MessageToLSpace */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
Xvoid Native_ShowMatchArgs(pMandRPB)
X    TPXMandRRec        pMandRPB;
X{
X    fprintf(stderr, "nancy %s: MandR arguments.\n", WHOAMI);
X
X    fprintf(stderr, "nancy %s: source:\n", WHOAMI);
X    Nancy_GroupleToStream(pMandRPB->pSrcGr, stderr);
X
X    fprintf(stderr, "nancy %s: pattern:\n", WHOAMI);
X    Nancy_GroupleToStream(pMandRPB->pPatGr, stderr);
X
X    fprintf(stderr, "nancy %s: destroyFlag: %s\n", WHOAMI,
X        pMandRPB->iDestroyFlag == NANCY_RemoveMatch ? "remove" :
X        pMandRPB->iDestroyFlag == NANCY_CopyMatch ? "copy" :
X        pMandRPB->iDestroyFlag == NANCY_ReplaceMatch ? "replace" : "unknown");
X
X    fprintf(stderr, "nancy %s: freqFlag: %s\n", WHOAMI,
X        pMandRPB->iFreqFlag == NANCY_MatchOne ? "one" : "all");
X
X    fprintf(stderr, "nancy %s: replace elt:\n", WHOAMI);
X    errprint(pMandRPB->pXReplaceElt);
X
X    fprintf(stderr, "nancy %s: stamp-time: ", WHOAMI);
X    if (pMandRPB->pStampTime)
X    PRINT_TIME(*pMandRPB->pStampTime, stderr);
X    else
X    fprintf(stderr, "nil");
X    fprintf(stderr, "\n");
X
X    fprintf(stderr, "nancy %s: test-time: ", WHOAMI);
X    if (pMandRPB->pTestTime)
X    PRINT_TIME(*pMandRPB->pTestTime, stderr);
X    else
X    fprintf(stderr, "nil");
X    fprintf(stderr, "\n");
X
X    }
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
Xvoid Native_ShowSite(pSite)
X    TPReplaceRec           pSite;
X{
X    fprintf(stderr, "nancy %s: site grouple:\n", WHOAMI);
X    Nancy_GroupleToStream(pSite->pEnviron, stderr);
X    fprintf(stderr, "nancy %s: site zones: %d\n", WHOAMI, pSite->iZones);
X    fprintf(stderr, "nancy %s: site insert elt: %d\n", WHOAMI, pSite->iInsertElt);
X    }
X/****************************************************************************************/
X
X
X
END_OF_FILE
if test 24300 -ne `wc -c <'src/kernel_current/shell/xv_native.c'`; then
    echo shar: \"'src/kernel_current/shell/xv_native.c'\" unpacked with wrong size!
fi
# end of 'src/kernel_current/shell/xv_native.c'
fi
if test -f 'src/xlisp/xcore/c/xleval.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xleval.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xleval.c'\" \(21287 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xleval.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xleval.c
X* RCS:          $Header: xleval.c,v 1.3 89/11/25 05:21:43 mayer Exp $
X* Description:  xlisp evaluator
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:21:14 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xleval.c,v 1.3 89/11/25 05:21:43 mayer Exp $";
X
X#include "xlisp.h"
X
X/* macro to check for lambda list keywords */
X#define iskey(s) ((s) == lk_optional \
X               || (s) == lk_rest \
X               || (s) == lk_key \
X               || (s) == lk_aux \
X               || (s) == lk_allow_other_keys)
X
X/* macros to handle tracing */
X#define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
X#define trexit(sym,val) {if (sym) doexit(sym,val);}
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xldenv,xlvalue,true;
Xextern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
Xextern LVAL s_evalhook,s_applyhook,s_tracelist;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_unbound;
Xextern int xlsample;
Xextern char buf[];
X
X/* forward declarations */
XFORWARD LVAL xlxeval();
XFORWARD LVAL evalhook();
XFORWARD LVAL evform();
XFORWARD LVAL evfun();
X
Xint iEvals = 0;            /* Voodoo */
X
X/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
XLVAL xleval(expr)
X  LVAL expr;
X{
X    /* check for control codes */
X    if (--xlsample <= 0) {
X    xlsample = SAMPLE;
X    oscheck();
X    }
X
X    iEvals ++;            /* Voodoo */
X
X    /* check for *evalhook* */
X    if (getvalue(s_evalhook))
X    return (evalhook(expr));
X
X    /* check for nil */
X    if (null(expr))
X    return (NIL);
X
X    /* dispatch on the node type */
X    switch (ntype(expr)) {
X    case CONS:
X    return (evform(expr));
X    case SYMBOL:
X    return (xlgetvalue(expr));
X    default:
X    return (expr);
X    }
X}
X
X#ifdef CURRENTLY_UNUSED
X/* xlevalenv - evaluate an expression in a specified environment */
XLVAL xlevalenv(expr,env,fenv)
X  LVAL expr,env,fenv;
X{
X    LVAL oldenv,oldfenv,val;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(oldenv);
X    xlsave(oldfenv);
X
X    /* establish the new environment */
X    oldenv = xlenv;
X    oldfenv = xlfenv;
X    xlenv = env;
X    xlfenv = fenv;
X
X    /* evaluate the expression */
X    val = xleval(expr);
X
X    /* restore the environment */
X    xlenv = oldenv;
X    xlfenv = oldfenv;
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the result value */
X    return (val);
X}
X#endif
X
X/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
XLVAL xlxeval(expr)
X  LVAL expr;
X{
X    /* check for nil */
X    if (null(expr))
X    return (NIL);
X
X    /* dispatch on node type */
X    switch (ntype(expr)) {
X    case CONS:
X    return (evform(expr));
X    case SYMBOL:
X    return (xlgetvalue(expr));
X    default:
X    return (expr);
X    }
X}
X
X/* xlapply - apply a function to arguments (already on the stack) */
XLVAL xlapply(argc)
X  int argc;
X{
X    LVAL *oldargv,fun,val;
X    int oldargc;
X
X    /* get the function */
X    fun = xlfp[1];
X
X    /* get the functional value of symbols */
X    if (symbolp(fun)) {
X    while ((val = getfunction(fun)) == s_unbound)
X        xlfunbound(fun);
X    fun = xlfp[1] = val;
X    }
X
X    /* check for nil */
X    if (null(fun))
X    xlerror("bad function",fun);
X
X    /* dispatch on node type */
X    switch (ntype(fun)) {
X    case SUBR:
X    oldargc = xlargc;
X    oldargv = xlargv;
X    xlargc = argc;
X    xlargv = xlfp + 3;
X    val = (*getsubr(fun))();
X    xlargc = oldargc;
X    xlargv = oldargv;
X    break;
X    case CONS:
X    if (!consp(cdr(fun)))
X        xlerror("bad function",fun);
X    if (car(fun) == s_lambda)
X        fun = xlclose(NIL,
X                      s_lambda,
X                      car(cdr(fun)),
X                      cdr(cdr(fun)),
X                      xlenv,xlfenv);
X    else
X        xlerror("bad function",fun);
X    /**** fall through into the next case ****/
X    case CLOSURE:
X    if (gettype(fun) != s_lambda)
X        xlerror("bad function",fun);
X    val = evfun(fun,argc,xlfp+3);
X    break;
X    default:
X    xlerror("bad function",fun);
X    }
X
X    /* remove the call frame */
X    xlsp = xlfp;
X    xlfp = xlfp - (int)getfixnum(*xlfp);
X
X    /* return the function value */
X    return (val);
X}
X
X/* evform - evaluate a form */
XLOCAL LVAL evform(form)
X  LVAL form;
X{
X    LVAL fun,args,val,type;
X    LVAL tracing=NIL;
X    LVAL *argv;
X    int argc;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fun);
X    xlsave(args);
X
X    /* get the function and the argument list */
X    fun = car(form);
X    args = cdr(form);
X
X    /* get the functional value of symbols */
X    if (symbolp(fun)) {
X    if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
X        tracing = fun;
X    fun = xlgetfunction(fun);
X    }
X
X    /* check for nil */
X    if (null(fun))
X    xlerror("bad function",NIL);
X
X    /* dispatch on node type */
X    switch (ntype(fun)) {
X    case SUBR:
X    argv = xlargv;
X    argc = xlargc;
X    xlargc = evpushargs(fun,args);
X    xlargv = xlfp + 3;
X    trenter(tracing,xlargc,xlargv);
X    val = (*getsubr(fun))();
X    trexit(tracing,val);
X    xlsp = xlfp;
X    xlfp = xlfp - (int)getfixnum(*xlfp);
X    xlargv = argv;
X    xlargc = argc;
X    break;
X    case FSUBR:
X    argv = xlargv;
X    argc = xlargc;
X    xlargc = pushargs(fun,args);
X    xlargv = xlfp + 3;
X    val = (*getsubr(fun))();
X    xlsp = xlfp;
X    xlfp = xlfp - (int)getfixnum(*xlfp);
X    xlargv = argv;
X    xlargc = argc;
X    break;
X    case CONS:
X    if (!consp(cdr(fun)))
X        xlerror("bad function",fun);
X    if ((type = car(fun)) == s_lambda)
X         fun = xlclose(NIL,
X                       s_lambda,
X                       car(cdr(fun)),
X                       cdr(cdr(fun)),
X                       xlenv,xlfenv);
X    else
X        xlerror("bad function",fun);
X    /**** fall through into the next case ****/
X    case CLOSURE:
X    if (gettype(fun) == s_lambda) {
X        argc = evpushargs(fun,args);
X        argv = xlfp + 3;
X        trenter(tracing,argc,argv);
X        val = evfun(fun,argc,argv);
X        trexit(tracing,val);
X        xlsp = xlfp;
X        xlfp = xlfp - (int)getfixnum(*xlfp);
X    }
X    else {
X        macroexpand(fun,args,&fun);
X        val = xleval(fun);
X    }
X    break;
X    default:
X    xlerror("bad function",fun);
X    }
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the result value */
X    return (val);
X}
X
X/* xlexpandmacros - expand macros in a form */
XLVAL xlexpandmacros(form)
X  LVAL form;
X{
X    LVAL fun,args;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlprotect(form);
X    xlsave(fun);
X    xlsave(args);
X
X    /* expand until the form isn't a macro call */
X    while (consp(form)) {
X    fun = car(form);        /* get the macro name */
X    args = cdr(form);        /* get the arguments */
X    if (!symbolp(fun) || !fboundp(fun))
X        break;
X    fun = xlgetfunction(fun);    /* get the expansion function */
X    if (!macroexpand(fun,args,&form))
X        break;
X    }
X
X    /* restore the stack and return the expansion */
X    xlpopn(3);
X    return (form);
X}
X
X/* macroexpand - expand a macro call */
Xint macroexpand(fun,args,pval)
X  LVAL fun,args,*pval;
X{
X    LVAL *argv;
X    int argc;
X
X    /* make sure it's really a macro call */
X    if (!closurep(fun) || gettype(fun) != s_macro)
X    return (FALSE);
X
X    /* call the expansion function */
X    argc = pushargs(fun,args);
X    argv = xlfp + 3;
X    *pval = evfun(fun,argc,argv);
X    xlsp = xlfp;
X    xlfp = xlfp - (int)getfixnum(*xlfp);
X    return (TRUE);
X}
X
X/* evalhook - call the evalhook function */
XLOCAL LVAL evalhook(expr)
X  LVAL expr;
X{
X    LVAL *newfp,olddenv,val;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(getvalue(s_evalhook));
X    pusharg(cvfixnum((FIXTYPE)2));
X    pusharg(expr);
X    pusharg(cons(xlenv,xlfenv));
X    xlfp = newfp;
X
X    /* rebind the hook functions to nil */
X    olddenv = xldenv;
X    xldbind(s_evalhook,NIL);
X    xldbind(s_applyhook,NIL);
X
X    /* call the hook function */
X    val = xlapply(2);
X
X    /* unbind the symbols */
X    xlunbind(olddenv);
X
X    /* return the value */
X    return (val);
X}
X
X/* evpushargs - evaluate and push a list of arguments */
XLOCAL int evpushargs(fun,args)
X  LVAL fun,args;
X{
X    LVAL *newfp;
X    int argc;
X
X    /* protect the argument list */
X    xlprot1(args);
X
X    /* build a new argument stack frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(NIL); /* will be argc */
X
X    /* evaluate and push each argument */
X    for (argc = 0; consp(args); args = cdr(args), ++argc)
X    pusharg(xleval(car(args)));
X
X    /* establish the new stack frame */
X    newfp[2] = cvfixnum((FIXTYPE)argc);
X    xlfp = newfp;
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the number of arguments */
X    return (argc);
X}
X
X/* pushargs - push a list of arguments */
Xint pushargs(fun,args)
X  LVAL fun,args;
X{
X    LVAL *newfp;
X    int argc;
X
X    /* build a new argument stack frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(NIL); /* will be argc */
X
X    /* push each argument */
X    for (argc = 0; consp(args); args = cdr(args), ++argc)
X    pusharg(car(args));
X
X    /* establish the new stack frame */
X    newfp[2] = cvfixnum((FIXTYPE)argc);
X    xlfp = newfp;
X
X    /* return the number of arguments */
X    return (argc);
X}
X
X/* makearglist - make a list of the remaining arguments */
XLVAL makearglist(argc,argv)
X  int argc; LVAL *argv;
X{
X    LVAL list,this,last;
X    xlsave1(list);
X    for (last = NIL; --argc >= 0; last = this) {
X    this = cons(*argv++,NIL);
X    if (last) rplacd(last,this);
X    else list = this;
X    }
X    xlpop();
X    return (list);
X}
X
X/* evfun - evaluate a function */
XLOCAL LVAL evfun(fun,argc,argv)
X  LVAL fun; int argc; LVAL *argv;
X{
X    LVAL oldenv,oldfenv,cptr,name,val;
X    CONTEXT cntxt;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(oldenv);
X    xlsave(oldfenv);
X    xlsave(cptr);
X
X    /* create a new environment frame */
X    oldenv = xlenv;
X    oldfenv = xlfenv;
X    xlenv = xlframe(xlgetenv(fun));
X    xlfenv = getfenv(fun);
X
X    /* bind the formal parameters */
X    xlabind(fun,argc,argv);
X
X    /* setup the implicit block */
X    if (name = getname(fun))
X    xlbegin(&cntxt,CF_RETURN,name);
X
X    /* execute the block */
X    if (name && xlsetjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else
X    for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr))
X        val = xleval(car(cptr));
X
X    /* finish the block context */
X    if (name)
X    xlend(&cntxt);
X
X    /* restore the environment */
X    xlenv = oldenv;
X    xlfenv = oldfenv;
X
X    /* restore the stack */
X    xlpopn(3);
X
X    /* return the result value */
X    return (val);
X}
X
X/* xlclose - create a function closure */
XLVAL xlclose(name,type,fargs,body,env,fenv)
X  LVAL name,type,fargs,body,env,fenv;
X{
X    LVAL closure,key,arg,def,svar,new,last;
X    char keyname[STRMAX+2];
X
X    /* protect some pointers */
X    xlsave1(closure);
X
X    /* create the closure object */
X    closure = newclosure(name,type,env,fenv);
X    setlambda(closure,fargs);
X    setbody(closure,body);
X
X    /* handle each required argument */
X    last = NIL;
X    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X    /* make sure the argument is a symbol */
X    if (!symbolp(arg))
X        badarglist();
X
X    /* create a new argument list entry */
X    new = cons(arg,NIL);
X
X    /* link it into the required argument list */
X    if (last)
X        rplacd(last,new);
X    else
X        setargs(closure,new);
X    last = new;
X
X    /* move the formal argument list pointer ahead */
X    fargs = cdr(fargs);
X    }
X
X    /* check for the '&optional' keyword */
X    if (consp(fargs) && car(fargs) == lk_optional) {
X    fargs = cdr(fargs);
X
X    /* handle each optional argument */
X    last = NIL;
X    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X        /* get the default expression and specified-p variable */
X        def = svar = NIL;
X        if (consp(arg)) {
X        if (def = cdr(arg))
X            if (consp(def)) {
X            if (svar = cdr(def))
X                if (consp(svar)) {
X                svar = car(svar);
X                if (!symbolp(svar))
X                    badarglist();
X                }
X                else
X                badarglist();
X            def = car(def);
X            }
X            else
X            badarglist();
X        arg = car(arg);
X        }
X
X        /* make sure the argument is a symbol */
X        if (!symbolp(arg))
X        badarglist();
X
X        /* create a fully expanded optional expression */
X        new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL);
X
X        /* link it into the optional argument list */
X        if (last)
X        rplacd(last,new);
X        else
X        setoargs(closure,new);
X        last = new;
X
X        /* move the formal argument list pointer ahead */
X        fargs = cdr(fargs);
X    }
X    }
X
X    /* check for the '&rest' keyword */
X    if (consp(fargs) && car(fargs) == lk_rest) {
X    fargs = cdr(fargs);
X
X    /* get the &rest argument */
X    if (consp(fargs) && (arg = car(fargs)) && !iskey(arg) && symbolp(arg))
X        setrest(closure,arg);
X    else
X        badarglist();
X
X    /* move the formal argument list pointer ahead */
X    fargs = cdr(fargs);
X    }
X
X    /* check for the '&key' keyword */
X    if (consp(fargs) && car(fargs) == lk_key) {
X    fargs = cdr(fargs);
X
X     /* handle each key argument */
X    last = NIL;
X    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X        /* get the default expression and specified-p variable */
X        def = svar = NIL;
X        if (consp(arg)) {
X        if (def = cdr(arg))
X            if (consp(def)) {
X            if (svar = cdr(def))
X                if (consp(svar)) {
X                svar = car(svar);
X                if (!symbolp(svar))
X                    badarglist();
X                }
X                else
X                badarglist();
X            def = car(def);
X            }
X            else
X            badarglist();
X        arg = car(arg);
X        }
X
X        /* get the keyword and the variable */
X        if (consp(arg)) {
X        key = car(arg);
X        if (!symbolp(key))
X            badarglist();
X        if (arg = cdr(arg))
X            if (consp(arg))
X            arg = car(arg);
X            else
X            badarglist();
X        }
X        else if (symbolp(arg)) {
X        strcpy(keyname,":");
X        strcat(keyname,getstring(getpname(arg)));
X        key = xlenter(keyname);
X        }
X
X        /* make sure the argument is a symbol */
X        if (!symbolp(arg))
X        badarglist();
X
X        /* create a fully expanded key expression */
X        new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL);
X
X        /* link it into the optional argument list */
X        if (last)
X        rplacd(last,new);
X        else
X        setkargs(closure,new);
X        last = new;
X
X        /* move the formal argument list pointer ahead */
X        fargs = cdr(fargs);
X    }
X    }
X
X    /* check for the '&allow-other-keys' keyword */
X    if (consp(fargs) && car(fargs) == lk_allow_other_keys)
X    fargs = cdr(fargs);    /* this is the default anyway */
X
X    /* check for the '&aux' keyword */
X    if (consp(fargs) && car(fargs) == lk_aux) {
X    fargs = cdr(fargs);
X
X    /* handle each aux argument */
X    last = NIL;
X    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X        /* get the initial value */
X        def = NIL;
X        if (consp(arg)) {
X        if (def = cdr(arg))
X            if (consp(def))
X            def = car(def);
X            else
X            badarglist();
X        arg = car(arg);
X        }
X
X        /* make sure the argument is a symbol */
X        if (!symbolp(arg))
X        badarglist();
X
X        /* create a fully expanded aux expression */
X        new = cons(cons(arg,cons(def,NIL)),NIL);
X
X        /* link it into the aux argument list */
X        if (last)
X        rplacd(last,new);
X        else
X        setaargs(closure,new);
X        last = new;
X
X        /* move the formal argument list pointer ahead */
X        fargs = cdr(fargs);
X    }
X    }
X
X    /* make sure this is the end of the formal argument list */
X    if (fargs)
X    badarglist();
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the new closure */
X    return (closure);
X}
X
X/* xlabind - bind the arguments for a function */
Xxlabind(fun,argc,argv)
X  LVAL fun; int argc; LVAL *argv;
X{
X    LVAL *kargv,fargs,key,arg,def,svar,p;
X    int rargc,kargc;
X
X    /* protect some pointers */
X    xlsave1(def);
X
X    /* bind each required argument */
X    for (fargs = getargs(fun); fargs; fargs = cdr(fargs)) {
X
X    /* make sure there is an actual argument */
X    if (--argc < 0)
X        xlfail("too few arguments");
X
X    /* bind the formal variable to the argument value */
X    xlbind(car(fargs),*argv++);
X    }
X
X    /* bind each optional argument */
X    for (fargs = getoargs(fun); fargs; fargs = cdr(fargs)) {
X
X    /* get argument, default and specified-p variable */
X    p = car(fargs);
X    arg = car(p); p = cdr(p);
X    def = car(p); p = cdr(p);
X    svar = car(p);
X
X    /* bind the formal variable to the argument value */
X    if (--argc >= 0) {
X        xlbind(arg,*argv++);
X        if (svar) xlbind(svar,true);
X    }
X
X    /* bind the formal variable to the default value */
X    else {
X        if (def) def = xleval(def);
X        xlbind(arg,def);
X        if (svar) xlbind(svar,NIL);
X    }
X    }
X
X    /* save the count of the &rest of the argument list */
X    rargc = argc;
X
X    /* handle '&rest' argument */
X    if (arg = getrest(fun)) {
X    def = makearglist(argc,argv);
X    xlbind(arg,def);
X    argc = 0;
X    }
X
X    /* handle '&key' arguments */
X    if (fargs = getkargs(fun)) {
X    for (; fargs; fargs = cdr(fargs)) {
X
X        /* get keyword, argument, default and specified-p variable */
X        p = car(fargs);
X        key = car(p); p = cdr(p);
X        arg = car(p); p = cdr(p);
X        def = car(p); p = cdr(p);
X        svar = car(p);
X
X        /* look for the keyword in the actual argument list */
X        for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2)
X        if (*kargv == key)
X            break;
X
X        /* bind the formal variable to the argument value */
X        if (kargc >= 0) {
X        xlbind(arg,*++kargv);
X        if (svar) xlbind(svar,true);
X        }
X
X        /* bind the formal variable to the default value */
X        else {
X        if (def) def = xleval(def);
X        xlbind(arg,def);
X        if (svar) xlbind(svar,NIL);
X        }
X    }
X    argc = 0;
X    }
X
X    /* check for the '&aux' keyword */
X    for (fargs = getaargs(fun); fargs; fargs = cdr(fargs)) {
X
X    /* get argument and default */
X    p = car(fargs);
X    arg = car(p); p = cdr(p);
X    def = car(p);
X
X    /* bind the auxiliary variable to the initial value */
X    if (def) def = xleval(def);
X    xlbind(arg,def);
X    }
X
X    /* make sure there aren't too many arguments */
X    if (argc > 0)
X    xlfail("too many arguments");
X
X    /* restore the stack */
X    xlpop();
X}
X
X/* doenter - print trace information on function entry */
XLOCAL doenter(sym,argc,argv)
X  LVAL sym; int argc; LVAL *argv;
X{
X    extern int xltrcindent;
X    int i;
X
X    /* indent to the current trace level */
X    for (i = 0; i < xltrcindent; ++i)
X    trcputstr(" ");
X    ++xltrcindent;
X
X    /* display the function call */
X    sprintf(buf,"Entering: %s, Argument list: (",getstring(getpname(sym)));
X    trcputstr(buf);
X    while (--argc >= 0) {
X    trcprin1(*argv++);
X    if (argc) trcputstr(" ");
X    }
X    trcputstr(")\n");
X}
X
X/* doexit - print trace information for function/macro exit */
XLOCAL doexit(sym,val)
X  LVAL sym,val;
X{
X    extern int xltrcindent;
X    int i;
X
X    /* indent to the current trace level */
X    --xltrcindent;
X    for (i = 0; i < xltrcindent; ++i)
X    trcputstr(" ");
X
X    /* display the function value */
X    sprintf(buf,"Exiting: %s, Value: ",getstring(getpname(sym)));
X    trcputstr(buf);
X    trcprin1(val);
X    trcputstr("\n");
X}
X
X/* member - is 'x' a member of 'list'? */
XLOCAL int member(x,list)
X  LVAL x,list;
X{
X    for (; consp(list); list = cdr(list))
X    if (x == car(list))
X        return (TRUE);
X    return (FALSE);
X}
X
X/* xlunbound - signal an unbound variable error */
Xxlunbound(sym)
X  LVAL sym;
X{
X    xlcerror("try evaluating symbol again","unbound variable",sym);
X}
X
X/* xlfunbound - signal an unbound function error */
Xxlfunbound(sym)
X  LVAL sym;
X{
X    xlcerror("try evaluating symbol again","unbound function",sym);
X}
X
X/* xlstkoverflow - signal a stack overflow error */
Xxlstkoverflow()
X{
X    xlabort("evaluation stack overflow");
X}
X
X/* xlargstkoverflow - signal an argument stack overflow error */
Xxlargstkoverflow()
X{
X    xlabort("argument stack overflow");
X}
X
X/* badarglist - report a bad argument list error */
XLOCAL badarglist()
X{
X    xlfail("bad formal argument list");
X}
END_OF_FILE
if test 21287 -ne `wc -c <'src/xlisp/xcore/c/xleval.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xleval.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xleval.c'
fi
if test -f 'src/xlisp/xcore/c/xlftab.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlftab.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlftab.c'\" \(22885 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlftab.c' <<'END_OF_FILE'
X/* xlftab.c - xlisp function table */
X/*    Copyright (c) 1985, by David Michael Betz */
X
X#include "xlisp.h"
X
X/* external functions */
Xextern LVAL
X    rmhash(),rmquote(),rmdquote(),rmbquote(),rmcomma(),
X    clnew(),clisnew(),clanswer(),
X    obisnew(),obclass(),obshow(),
X    rmlpar(),rmrpar(),rmsemi(),
X    xeval(),xapply(),xfuncall(),xquote(),xfunction(),xbquote(),
X    xlambda(),xset(),xsetq(),xsetf(),xdefun(),xdefmacro(),
X    xgensym(),xmakesymbol(),xintern(),
X    xsymname(),xsymvalue(),xsymplist(),
X    xget(),xputprop(),xremprop(),
X    xhash(),xmkarray(),xaref(),
X    xcar(),xcdr(),
X    xcaar(),xcadr(),xcdar(),xcddr(),
X    xcaaar(),xcaadr(),xcadar(),xcaddr(),
X    xcdaar(),xcdadr(),xcddar(),xcdddr(),
X    xcaaaar(),xcaaadr(),xcaadar(),xcaaddr(),
X    xcadaar(),xcadadr(),xcaddar(),xcadddr(),
X    xcdaaar(),xcdaadr(),xcdadar(),xcdaddr(),
X    xcddaar(),xcddadr(),xcdddar(),xcddddr(),
X    xcons(),xlist(),xappend(),xreverse(),xlast(),xnth(),xnthcdr(),
X    xmember(),xassoc(),xsubst(),xsublis(),xlength(),xsort(),
X    xremove(),xremif(),xremifnot(),
X    xmapc(),xmapcar(),xmapl(),xmaplist(),
X    xrplca(),xrplcd(),xnconc(),
X    xdelete(),xdelif(),xdelifnot(),
X    xatom(),xsymbolp(),xnumberp(),xboundp(),xnull(),xlistp(),xendp(),xconsp(),
X    xeq(),xeql(),xequal(),
X    xcond(),xcase(),xand(),xor(),xlet(),xletstar(),xif(),
X    xprog(),xprogstar(),xprog1(),xprog2(),xprogn(),xgo(),xreturn(),
X    xcatch(),xthrow(),
X    xerror(),xcerror(),xbreak(),
X    xcleanup(),xtoplevel(),xcontinue(),xerrset(),
X    xbaktrace(),xevalhook(),
X    xdo(),xdostar(),xdolist(),xdotimes(),
X    xminusp(),xzerop(),xplusp(),xevenp(),xoddp(),
X    xfix(),xfloat(),
X    xgcd(),xadd(),xsub(),xmul(),xdiv(),xrem(),xmin(),xmax(),xabs(),
X    xadd1(),xsub1(),xlogand(),xlogior(),xlogxor(),xlognot(),
X    xsin(),xcos(),xtan(),xexpt(),xexp(),xsqrt(),xrand(),
X    xlss(),xleq(),xequ(),xneq(),xgeq(),xgtr(),
X    xstrcat(),xsubseq(),xstring(),xchar(),
X    xread(),xprint(),xprin1(),xprinc(),xterpri(),
X    xflatsize(),xflatc(),
X    xopen(),xclose(),xrdchar(),xpkchar(),xwrchar(),xreadline(),
X    xload(),xtranscript(),
X    xtype(),xexit(),xpeek(),xpoke(),xaddrs(),
X    xvector(),xblock(),xrtnfrom(),xtagbody(),
X    xpsetq(),xflet(),xlabels(),xmacrolet(),xunwindprotect(),xpp(),
X    xstrlss(),xstrleq(),xstreql(),xstrneq(),xstrgeq(),xstrgtr(),
X    xstrilss(),xstrileq(),xstrieql(),xstrineq(),xstrigeq(),xstrigtr(),
X    xupcase(),xdowncase(),xnupcase(),xndowncase(),
X    xtrim(),xlefttrim(),xrighttrim(),
X    xuppercasep(),xlowercasep(),xbothcasep(),xdigitp(),xalphanumericp(),
X    xcharcode(),xcodechar(),xchupcase(),xchdowncase(),xdigitchar(),
X    xchrlss(),xchrleq(),xchreql(),xchrneq(),xchrgeq(),xchrgtr(),
X    xchrilss(),xchrileq(),xchrieql(),xchrineq(),xchrigeq(),xchrigtr(),
X    xintegerp(),xfloatp(),xstringp(),xarrayp(),xstreamp(),xobjectp(),
X    xwhen(),xunless(),xloop(),
X    xsymfunction(),xfboundp(),xsend(),xsendsuper(),
X    xprogv(),xrdbyte(),xwrbyte(),xformat(),
X    xcharp(),xcharint(),xintchar(),
X    xmkstrinput(),xmkstroutput(),xgetstroutput(),xgetlstoutput(),
X    xgetlambda(),xmacroexpand(),x1macroexpand(),
X    xtrace(),xuntrace(),
X    xdefstruct(),xmkstruct(),xcpystruct(),xstrref(),xstrset(),xstrtypep(),
X    xasin(),xacos(),xatan(),
X    Prim_POPEN(), Prim_PCLOSE(), Prim_SYSTEM(),    /* NPM */
X    Prim_FSCANF_FIXNUM(), Prim_FSCANF_STRING(), Prim_FSCANF_FLONUM(), /* NPM */
X    Prim_COPY_ARRAY(), Prim_ARRAY_INSERT_POS(), Prim_ARRAY_DELETE_POS(); /* NPM */
X
Xextern LVAL xosenvget(); /* JSP */
Xextern void xlinclude_hybrid_prims(); /* Voodoo */
X
X/* Include hybrid-class functions: *//* JSP */
X#define MODULE_XLFTAB_C_GLOBALS
X#include "../../xmodules.h"
X#undef MODULE_XLFTAB_C_GLOBALS
X
X/* functions specific to xldmem.c */
XLVAL xgc(),xexpand(),xalloc(),xmem();
X#ifdef SAVERESTORE
XLVAL xsave(),xrestore();
X#endif
X
X/* include system dependent definitions */
X#include "osdefs.h"
X
X/* SUBR/FSUBR indicator */
X#define S    SUBR
X#define F    FSUBR
X
X/* forward declarations */
XLVAL xnotimp();
X
X/* the function table */
XFUNDEF *funtab;
X
X/* and its associated parts */ /* Voodoo */
X#define xlisp_prim_max 500
Xint    iPrimCount;
X
X
X/* xlfinit - setup xlisp function table */ /* Voodoo */
Xvoid xlfinit()
X{
X    int        iIndex;
X
X    if (funtab = (FUNDEF *) malloc(xlisp_prim_max * sizeof(FUNDEF))) {
X
X    iPrimCount = 0;
X
X    /* load xlisp native prims, updates iPrimCount global */
X    xlinclude_native_prims();
X
X    /* load user's hybrid prims, updates iPrimCount global */
X    xlinclude_hybrid_prims();
X
X    /* reserve a slot for sentinel */
X    funtab[iPrimCount].fd_name = 0;
X    funtab[iPrimCount].fd_type = 0;
X    funtab[iPrimCount].fd_subr = 0;
X    iPrimCount ++;
X
X    /* allocate permanent global funtable of exact size */
X    funtab = (FUNDEF *) realloc(funtab, iPrimCount * sizeof(FUNDEF));
X    }
X
X    } /* xlfinit */
X
X
X
X/*  xldefine_prim - enter xlisp prim into xlisp function table */
Xvoid xldefine_prim(sName, iType, pFun)  /* Voodoo */
X    char        *sName;
X    int            iType;
X    LVAL         (*pFun)();
X{
X    funtab[iPrimCount].fd_name = sName;
X    funtab[iPrimCount].fd_type = iType;
X    funtab[iPrimCount].fd_subr = pFun;
X    iPrimCount ++;
X    }
X
X
X
X/* xnotimp - function table entries that are currently not implemented */
XLOCAL LVAL xnotimp()
X{
X    xlfail("function not implemented");
X}
X
X/* funtab_offset - find given fn in funtab. */        /* JSP */
X/* (Obviates need for hacks like FT_CLNEW.) */          /* JSP */
XLOCAL int funtab_index = 0; /* For O(1) lookup time on ordered requests. */
Xfuntab_offset(fn)                    /* JSP */
XLVAL        (*fn)();                    /* JSP */
X{                            /* JSP */
X    int wrapCount = 0;                    /* JSP */
X    while (wrapCount < 2) {                /* JSP */
X        LVAL (*e)() = funtab[ funtab_index ].fd_subr;    /* JSP */
X        if (e == fn)   return funtab_index;        /* JSP */
X        if (e)              ++funtab_index;        /* JSP */
X        else {++wrapCount;    funtab_index = 0;}    /* JSP */
X    }                            /* JSP */
X    xlfatal("funtab_offset: internal error");        /* JSP */
X}                            /* JSP */
X
X
X
X
Xxlinclude_native_prims()
X{
X    /* read macro functions */
X
X
Xxldefine_prim(NULL,        S, rmhash        ); /*   0 */
Xxldefine_prim(NULL,        S, rmquote        ); /*   1 */
Xxldefine_prim(NULL,        S, rmdquote        ); /*   2 */
Xxldefine_prim(NULL,        S, rmbquote        ); /*   3 */
Xxldefine_prim(NULL,        S, rmcomma        ); /*   4 */
Xxldefine_prim(NULL,        S, rmlpar        ); /*   5 */
Xxldefine_prim(NULL,        S, rmrpar        ); /*   6 */
Xxldefine_prim(NULL,        S, rmsemi        ); /*   7 */
Xxldefine_prim(NULL,        S, xnotimp        ); /*   8 */
X#ifdef ORIGINAL
Xxldefine_prim(NULL,        S, xnotimp        ); /*   9 */
X#else
X    /* BUGGO,need to put envget somewhere else. */
Xxldefine_prim("GETENV",        S, xosenvget        ); /*   9 */
X#endif
X
X    /* methods */
Xxldefine_prim(NULL,        S, clnew        ); /*  10 */
Xxldefine_prim(NULL,        S, clisnew        ); /*  11 */
Xxldefine_prim(NULL,        S, clanswer        ); /*  12 */
Xxldefine_prim(NULL,        S, obisnew        ); /*  13 */
Xxldefine_prim(NULL,        S, obclass        ); /*  14 */
Xxldefine_prim(NULL,        S, obshow        ); /*  15 */
Xxldefine_prim(NULL,        S, xnotimp        ); /*  16 */
Xxldefine_prim(NULL,        S, xnotimp        ); /*  17 */
Xxldefine_prim(NULL,        S, xnotimp        ); /*  18 */
Xxldefine_prim(NULL,        S, xnotimp        ); /*  19 */
X
X    /* evaluator functions */
Xxldefine_prim("EVAL",        S, xeval        ); /*  20 */
Xxldefine_prim("APPLY",        S, xapply        ); /*  21 */
Xxldefine_prim("FUNCALL",    S, xfuncall        ); /*  22 */
Xxldefine_prim("QUOTE",        F, xquote        ); /*  23 */
Xxldefine_prim("FUNCTION",    F, xfunction        ); /*  24 */
Xxldefine_prim("BACKQUOTE",    F, xbquote        ); /*  25 */
Xxldefine_prim("LAMBDA",        F, xlambda        ); /*  26 */
X
X    /* symbol functions */
Xxldefine_prim("SET",        S, xset            ); /*  27 */
Xxldefine_prim("SETQ",        F, xsetq        ); /*  28 */
Xxldefine_prim("SETF",        F, xsetf        ); /*  29 */
Xxldefine_prim("DEFUN",        F, xdefun        ); /*  30 */
Xxldefine_prim("DEFMACRO",    F, xdefmacro        ); /*  31 */
Xxldefine_prim("GENSYM",        S, xgensym        ); /*  32 */
Xxldefine_prim("MAKE-SYMBOL",    S, xmakesymbol        ); /*  33 */
Xxldefine_prim("INTERN",     S, xintern        ); /*  34 */
Xxldefine_prim("SYMBOL-NAME",    S, xsymname        ); /*  35 */
Xxldefine_prim("SYMBOL-VALUE",    S, xsymvalue        ); /*  36 */
Xxldefine_prim("SYMBOL-PLIST",    S, xsymplist        ); /*  37 */
Xxldefine_prim("GET",        S, xget    ); /*  38 */
Xxldefine_prim("PUTPROP",    S, xputprop); /*  39 */
Xxldefine_prim("REMPROP",    S, xremprop        ); /*  40 */
Xxldefine_prim("HASH",        S, xhash        ); /*  41 */
X
X    /* array functions */
Xxldefine_prim("MAKE-ARRAY",    S, xmkarray        ); /*  42 */
Xxldefine_prim("AREF",        S, xaref        ); /*  43 */
X
X    /* list functions */
Xxldefine_prim("CAR",        S, xcar            ); /*  44 */
Xxldefine_prim("CDR",        S, xcdr            ); /*  45 */
X
Xxldefine_prim("CAAR",        S, xcaar        ); /*  46 */
Xxldefine_prim("CADR",        S, xcadr        ); /*  47 */
Xxldefine_prim("CDAR",        S, xcdar        ); /*  48 */
Xxldefine_prim("CDDR",        S, xcddr        ); /*  49 */
X
Xxldefine_prim("CAAAR",        S, xcaaar        ); /*  50 */
Xxldefine_prim("CAADR",        S, xcaadr        ); /*  51 */
Xxldefine_prim("CADAR",        S, xcadar        ); /*  52 */
Xxldefine_prim("CADDR",        S, xcaddr        ); /*  53 */
Xxldefine_prim("CDAAR",        S, xcdaar        ); /*  54 */
Xxldefine_prim("CDADR",        S, xcdadr        ); /*  55 */
Xxldefine_prim("CDDAR",        S, xcddar        ); /*  56 */
Xxldefine_prim("CDDDR",        S, xcdddr        ); /*  57 */
X
Xxldefine_prim("CAAAAR",     S, xcaaaar        ); /*  58 */
Xxldefine_prim("CAAADR",        S, xcaaadr        ); /*  59 */
Xxldefine_prim("CAADAR",        S, xcaadar        ); /*  60 */
Xxldefine_prim("CAADDR",        S, xcaaddr        ); /*  61 */
Xxldefine_prim("CADAAR",        S, xcadaar        ); /*  62 */
Xxldefine_prim("CADADR",        S, xcadadr        ); /*  63 */
Xxldefine_prim("CADDAR",        S, xcaddar        ); /*  64 */
Xxldefine_prim("CADDDR",        S, xcadddr        ); /*  65 */
Xxldefine_prim("CDAAAR",        S, xcdaaar        ); /*  66 */
Xxldefine_prim("CDAADR",        S, xcdaadr        ); /*  67 */
Xxldefine_prim("CDADAR",        S, xcdadar        ); /*  68 */
Xxldefine_prim("CDADDR",        S, xcdaddr        ); /*  69 */
Xxldefine_prim("CDDAAR",        S, xcddaar        ); /*  70 */
Xxldefine_prim("CDDADR",        S, xcddadr        ); /*  71 */
Xxldefine_prim("CDDDAR",        S, xcdddar        ); /*  72 */
Xxldefine_prim("CDDDDR",        S, xcddddr        ); /*  73 */
X
Xxldefine_prim("CONS",        S, xcons        ); /*  74 */
Xxldefine_prim("LIST",        S, xlist        ); /*  75 */
Xxldefine_prim("APPEND",        S, xappend        ); /*  76 */
Xxldefine_prim("REVERSE",    S, xreverse        ); /*  77 */
Xxldefine_prim("LAST",        S, xlast        ); /*  78 */
Xxldefine_prim("NTH",        S, xnth            ); /*  79 */
Xxldefine_prim("NTHCDR",        S, xnthcdr        ); /*  80 */
Xxldefine_prim("MEMBER",        S, xmember        ); /*  81 */
Xxldefine_prim("ASSOC",        S, xassoc        ); /*  82 */
Xxldefine_prim("SUBST",         S, xsubst        ); /*  83 */
Xxldefine_prim("SUBLIS",        S, xsublis        ); /*  84 */
Xxldefine_prim("REMOVE",        S, xremove        ); /*  85 */
Xxldefine_prim("LENGTH",        S, xlength        ); /*  86 */
Xxldefine_prim("MAPC",        S, xmapc        ); /*  87 */
Xxldefine_prim("MAPCAR",        S, xmapcar        ); /*  88 */
Xxldefine_prim("MAPL",        S, xmapl        ); /*  89 */
Xxldefine_prim("MAPLIST",    S, xmaplist        ); /*  90 */
X
X    /* destructive list functions */
Xxldefine_prim("RPLACA",        S, xrplca        ); /*  91 */
Xxldefine_prim("RPLACD",        S, xrplcd        ); /*  92 */
Xxldefine_prim("NCONC",        S, xnconc        ); /*  93 */
Xxldefine_prim("DELETE",        S, xdelete        ); /*  94 */
X
X    /* predicate functions */
Xxldefine_prim("ATOM",        S, xatom        ); /*  95 */
Xxldefine_prim("SYMBOLP",    S, xsymbolp        ); /*  96 */
Xxldefine_prim("NUMBERP",    S, xnumberp        ); /*  97 */
Xxldefine_prim("BOUNDP",        S, xboundp         ); /*  98 */
Xxldefine_prim("NULL",        S, xnull        ); /*  99 */
Xxldefine_prim("LISTP",        S, xlistp        ); /* 100 */
Xxldefine_prim("CONSP",        S, xconsp        ); /* 101 */
Xxldefine_prim("MINUSP",        S, xminusp         ); /* 102 */
Xxldefine_prim("ZEROP",        S, xzerop        ); /* 103 */
Xxldefine_prim("PLUSP",        S, xplusp        ); /* 104 */
Xxldefine_prim("EVENP",        S, xevenp        ); /* 105 */
Xxldefine_prim("ODDP",        S, xoddp        ); /* 106 */
Xxldefine_prim("EQ",        S, xeq            ); /* 107 */
Xxldefine_prim("EQL",        S, xeql            ); /* 108 */
Xxldefine_prim("EQUAL",        S, xequal        ); /* 109 */
X
X    /* special forms */
Xxldefine_prim("COND",        F, xcond        ); /* 110 */
Xxldefine_prim("CASE",        F, xcase        ); /* 111 */
Xxldefine_prim("AND",        F, xand            ); /* 112 */
Xxldefine_prim("OR",        F, xor            ); /* 113 */
Xxldefine_prim("LET",        F, xlet            ); /* 114 */
Xxldefine_prim("LET*",        F, xletstar        ); /* 115 */
Xxldefine_prim("IF",        F, xif            ); /* 116 */
Xxldefine_prim("PROG",        F, xprog        ); /* 117 */
Xxldefine_prim("PROG*",        F, xprogstar        ); /* 118 */
Xxldefine_prim("PROG1",        F, xprog1        ); /* 119 */
Xxldefine_prim("PROG2",        F, xprog2        ); /* 120 */
Xxldefine_prim("PROGN",        F, xprogn        ); /* 121 */
Xxldefine_prim("GO",        F, xgo            ); /* 122 */
Xxldefine_prim("RETURN",        F, xreturn          ); /* 123 */
Xxldefine_prim("DO",        F, xdo            ); /* 124 */
Xxldefine_prim("DO*",        F, xdostar          ); /* 125 */
Xxldefine_prim("DOLIST",        F, xdolist          ); /* 126 */
Xxldefine_prim("DOTIMES",    F, xdotimes        ); /* 127 */
Xxldefine_prim("CATCH",        F, xcatch        ); /* 128 */
Xxldefine_prim("THROW",        F, xthrow        ); /* 129 */
X
X    /* debugging and error handling functions */
Xxldefine_prim("ERROR",        S, xerror        ); /* 130 */
Xxldefine_prim("CERROR",        S, xcerror          ); /* 131 */
Xxldefine_prim("BREAK",        S, xbreak        ); /* 132 */
Xxldefine_prim("CLEAN-UP",    S, xcleanup        ); /* 133 */
Xxldefine_prim("TOP-LEVEL",    S, xtoplevel        ); /* 134 */
Xxldefine_prim("CONTINUE",    S, xcontinue        ); /* 135 */
Xxldefine_prim("ERRSET",     F, xerrset          ); /* 136 */
Xxldefine_prim("BAKTRACE",       S, xbaktrace        ); /* 137 */
Xxldefine_prim("EVALHOOK",    S, xevalhook        ); /* 138 */
X
X    /* arithmetic functions */
Xxldefine_prim("TRUNCATE",    S, xfix            ); /* 139 */
Xxldefine_prim("FLOAT",        S, xfloat        ); /* 140 */
Xxldefine_prim("+",        S, xadd            ); /* 141 */
Xxldefine_prim("-",        S, xsub            ); /* 142 */
Xxldefine_prim("*",        S, xmul            ); /* 143 */
Xxldefine_prim("/",        S, xdiv            ); /* 144 */
Xxldefine_prim("1+",        S, xadd1        ); /* 145 */
Xxldefine_prim("1-",        S, xsub1        ); /* 146 */
Xxldefine_prim("REM",        S, xrem            ); /* 147 */
Xxldefine_prim("MIN",        S, xmin            ); /* 148 */
Xxldefine_prim("MAX",        S, xmax            ); /* 149 */
Xxldefine_prim("ABS",        S, xabs            ); /* 150 */
Xxldefine_prim("SIN",        S, xsin            ); /* 151 */
Xxldefine_prim("COS",        S, xcos            ); /* 152 */
Xxldefine_prim("TAN",        S, xtan            ); /* 153 */
Xxldefine_prim("EXPT",        S, xexpt        ); /* 154 */
Xxldefine_prim("EXP",        S, xexp            ); /* 155 */
Xxldefine_prim("SQRT",        S, xsqrt        ); /* 156 */
Xxldefine_prim("RANDOM",        S, xrand        ); /* 157 */
X
X    /* bitwise logical functions */
Xxldefine_prim("LOGAND",        S, xlogand          ); /* 158 */
Xxldefine_prim("LOGIOR",        S, xlogior          ); /* 159 */
Xxldefine_prim("LOGXOR",        S, xlogxor          ); /* 160 */
Xxldefine_prim("LOGNOT",        S, xlognot          ); /* 161 */
X
X    /* numeric comparison functions */
Xxldefine_prim("<",        S, xlss            ); /* 162 */
Xxldefine_prim("<=",        S, xleq            ); /* 163 */
Xxldefine_prim("=",        S, xequ            ); /* 164 */
Xxldefine_prim("/=",        S, xneq            ); /* 165 */
Xxldefine_prim(">=",        S, xgeq            ); /* 166 */
Xxldefine_prim(">",        S, xgtr            ); /* 167 */
X
X    /* string functions */
Xxldefine_prim("STRCAT",        S, xstrcat          ); /* 168 */
Xxldefine_prim("SUBSEQ",        S, xsubseq          ); /* 169 */
Xxldefine_prim("STRING",        S, xstring          ); /* 170 */
Xxldefine_prim("CHAR",        S, xchar        ); /* 171 */
X
X    /* I/O functions */
Xxldefine_prim("READ",        S, xread        ); /* 172 */
Xxldefine_prim("PRINT",        S, xprint        ); /* 173 */
Xxldefine_prim("PRIN1",        S, xprin1        ); /* 174 */
Xxldefine_prim("PRINC",        S, xprinc        ); /* 175 */
Xxldefine_prim("TERPRI",        S, xterpri          ); /* 176 */
Xxldefine_prim("FLATSIZE",    S, xflatsize        ); /* 177 */
Xxldefine_prim("FLATC",        S, xflatc        ); /* 178 */
X
X    /* file I/O functions */
Xxldefine_prim("OPEN",        S, xopen        ); /* 179 */
Xxldefine_prim("FORMAT",        S, xformat          ); /* 180 */
Xxldefine_prim("CLOSE",        S, xclose        ); /* 181 */
Xxldefine_prim("READ-CHAR",    S, xrdchar          ); /* 182 */
Xxldefine_prim("PEEK-CHAR",    S, xpkchar          ); /* 183 */
Xxldefine_prim("WRITE-CHAR",    S, xwrchar          ); /* 184 */
Xxldefine_prim("READ-LINE",    S, xreadline        ); /* 185 */
X
X    /* system functions */
Xxldefine_prim("LOAD",        S, xload        ); /* 186 */
Xxldefine_prim("DRIBBLE",    S, xtranscript        ); /* 187 */
X
X    /* functions specific to xldmem.c */
Xxldefine_prim("GC",        S, xgc            ); /* 188 */
Xxldefine_prim("EXPAND",        S, xexpand          ); /* 189 */
Xxldefine_prim("ALLOC",        S, xalloc        ); /* 190 */
Xxldefine_prim("ROOM",        S, xmem            ); /* 191 */
X#ifdef SAVERESTORE
Xxldefine_prim("SAVE",        S, xsave        ); /* 192 */
Xxldefine_prim("RESTORE",    S, xrestore        ); /* 193 */
X#else
Xxldefine_prim(NULL,        S, xnotimp        ); /* 192 */
Xxldefine_prim(NULL,        S, xnotimp        ); /* 193 */
X#endif
X    /* end of functions specific to xldmem.c */
X
Xxldefine_prim("TYPE-OF",    S, xtype        ); /* 194 */
Xxldefine_prim("EXIT",        S, xexit        ); /* 195 */
Xxldefine_prim("PEEK",        S, xpeek        ); /* 196 */
Xxldefine_prim("POKE",        S, xpoke        ); /* 197 */
Xxldefine_prim("ADDRESS-OF",    S, xaddrs        ); /* 198 */
X
X    /* new functions and special forms */
Xxldefine_prim("VECTOR",        S, xvector          ); /* 199 */
Xxldefine_prim("BLOCK",        F, xblock        ); /* 200 */
Xxldefine_prim("RETURN-FROM",    F, xrtnfrom        ); /* 201 */
Xxldefine_prim("TAGBODY",    F, xtagbody        ); /* 202 */
Xxldefine_prim("PSETQ",        F, xpsetq        ); /* 203 */
Xxldefine_prim("FLET",        F, xflet        ); /* 204 */
Xxldefine_prim("LABELS",        F, xlabels          ); /* 205 */
Xxldefine_prim("MACROLET",    F, xmacrolet        ); /* 206 */
Xxldefine_prim("UNWIND-PROTECT",    F, xunwindprotect    ); /* 207 */
Xxldefine_prim("PPRINT",        S, xpp            ); /* 208 */
Xxldefine_prim("STRING<",    S, xstrlss          ); /* 209 */
Xxldefine_prim("STRING<=",    S, xstrleq          ); /* 210 */
Xxldefine_prim("STRING=",    S, xstreql          ); /* 211 */
Xxldefine_prim("STRING/=",    S, xstrneq          ); /* 212 */
Xxldefine_prim("STRING>=",    S, xstrgeq          ); /* 213 */
Xxldefine_prim("STRING>",    S, xstrgtr          ); /* 214 */
Xxldefine_prim("STRING-LESSP",        S, xstrilss        ); /* 215 */
Xxldefine_prim("STRING-NOT-GREATERP",    S, xstrileq        ); /* 216 */
Xxldefine_prim("STRING-EQUAL",        S, xstrieql        ); /* 217 */
Xxldefine_prim("STRING-NOT-EQUAL",    S, xstrineq        ); /* 218 */
Xxldefine_prim("STRING-NOT-LESSP",    S, xstrigeq        ); /* 219 */
Xxldefine_prim("STRING-GREATERP",    S, xstrigtr        ); /* 220 */
Xxldefine_prim("INTEGERP",        S, xintegerp        ); /* 221 */
Xxldefine_prim("FLOATP",            S, xfloatp          ); /* 222 */
Xxldefine_prim("STRINGP",        S, xstringp        ); /* 223 */
Xxldefine_prim("ARRAYP",            S, xarrayp          ); /* 224 */
Xxldefine_prim("STREAMP",        S, xstreamp        ); /* 225 */
Xxldefine_prim("OBJECTP",        S, xobjectp        ); /* 226 */
Xxldefine_prim("STRING-UPCASE",        S, xupcase          ); /* 227 */
Xxldefine_prim("STRING-DOWNCASE",    S, xdowncase        ); /* 228 */
Xxldefine_prim("NSTRING-UPCASE",        S, xnupcase        ); /* 229 */
Xxldefine_prim("NSTRING-DOWNCASE",    S, xndowncase        ); /* 230 */
Xxldefine_prim("STRING-TRIM",        S, xtrim        ); /* 231 */
Xxldefine_prim("STRING-LEFT-TRIM",    S, xlefttrim        ); /* 232 */
Xxldefine_prim("STRING-RIGHT-TRIM",    S, xrighttrim        ); /* 233 */
Xxldefine_prim("WHEN",            F, xwhen        ); /* 234 */
Xxldefine_prim("UNLESS",            F, xunless          ); /* 235 */
Xxldefine_prim("LOOP",            F, xloop        ); /* 236 */
Xxldefine_prim("SYMBOL-FUNCTION",    S, xsymfunction        ); /* 237 */
Xxldefine_prim("FBOUNDP",        S, xfboundp        ); /* 238 */
Xxldefine_prim("SEND",            S, xsend        ); /* 239 */
Xxldefine_prim("SEND-SUPER",        S, xsendsuper        ); /* 240 */
Xxldefine_prim("PROGV",            F, xprogv        ); /* 241 */
Xxldefine_prim("CHARACTERP",        S, xcharp        ); /* 242 */
Xxldefine_prim("CHAR-INT",        S, xcharint        ); /* 243 */
Xxldefine_prim("INT-CHAR",        S, xintchar        ); /* 244 */
Xxldefine_prim("READ-BYTE",        S, xrdbyte          ); /* 245 */
Xxldefine_prim("WRITE-BYTE",        S, xwrbyte          ); /* 246 */
Xxldefine_prim("MAKE-STRING-INPUT-STREAM",     S, xmkstrinput        ); /* 247 */
Xxldefine_prim("MAKE-STRING-OUTPUT-STREAM",    S, xmkstroutput        ); /* 248 */
Xxldefine_prim("GET-OUTPUT-STREAM-STRING",    S, xgetstroutput    ); /* 249 */
Xxldefine_prim("GET-OUTPUT-STREAM-LIST",    S, xgetlstoutput    ); /* 250 */
Xxldefine_prim("GCD",            S, xgcd            ); /* 251 */
Xxldefine_prim("GET-LAMBDA-EXPRESSION",     S, xgetlambda        ); /* 252 */
Xxldefine_prim("MACROEXPAND",        S, xmacroexpand        ); /* 253 */
Xxldefine_prim("MACROEXPAND-1",        S, x1macroexpand    ); /* 254 */
Xxldefine_prim("CHAR<",            S, xchrlss          ); /* 255 */
Xxldefine_prim("CHAR<=",            S, xchrleq          ); /* 256 */
Xxldefine_prim("CHAR=",            S, xchreql          ); /* 257 */
Xxldefine_prim("CHAR/=",            S, xchrneq          ); /* 258 */
Xxldefine_prim("CHAR>=",            S, xchrgeq          ); /* 259 */
Xxldefine_prim("CHAR>",            S, xchrgtr          ); /* 260 */
Xxldefine_prim("CHAR-LESSP",        S, xchrilss        ); /* 261 */
Xxldefine_prim("CHAR-NOT-GREATERP",    S, xchrileq        ); /* 262 */
Xxldefine_prim("CHAR-EQUAL",        S, xchrieql        ); /* 263 */
Xxldefine_prim("CHAR-NOT-EQUAL",        S, xchrineq        ); /* 264 */
Xxldefine_prim("CHAR-NOT-LESSP",        S, xchrigeq        ); /* 265 */
Xxldefine_prim("CHAR-GREATERP",        S, xchrigtr        ); /* 266 */
Xxldefine_prim("UPPER-CASE-P",        S, xuppercasep        ); /* 267 */
Xxldefine_prim("LOWER-CASE-P",        S, xlowercasep        ); /* 268 */
Xxldefine_prim("BOTH-CASE-P",        S, xbothcasep        ); /* 269 */
Xxldefine_prim("DIGIT-CHAR-P",        S, xdigitp        ); /* 270 */
Xxldefine_prim("ALPHANUMERICP",        S, xalphanumericp    ); /* 271 */
Xxldefine_prim("CHAR-UPCASE",        S, xchupcase        ); /* 272 */
Xxldefine_prim("CHAR-DOWNCASE",        S, xchdowncase        ); /* 273 */
Xxldefine_prim("DIGIT-CHAR",        S, xdigitchar        ); /* 274 */
Xxldefine_prim("CHAR-CODE",        S, xcharcode        ); /* 275 */
Xxldefine_prim("CODE-CHAR",        S, xcodechar        ); /* 276 */
Xxldefine_prim("ENDP",            S, xendp        ); /* 277 */
Xxldefine_prim("REMOVE-IF",        S, xremif        ); /* 278 */
Xxldefine_prim("REMOVE-IF-NOT",        S, xremifnot        ); /* 279 */
Xxldefine_prim("DELETE-IF",        S, xdelif        ); /* 280 */
Xxldefine_prim("DELETE-IF-NOT",        S, xdelifnot        ); /* 281 */
Xxldefine_prim("TRACE",            F, xtrace        ); /* 282 */
Xxldefine_prim("UNTRACE",        F, xuntrace        ); /* 283 */
Xxldefine_prim("SORT",            S, xsort        ); /* 284 */
Xxldefine_prim("DEFSTRUCT",        F, xdefstruct        ); /* 285 */
Xxldefine_prim("%STRUCT-TYPE-P",        S, xstrtypep        ); /* 286 */
Xxldefine_prim("%MAKE-STRUCT",        S, xmkstruct        ); /* 287 */
Xxldefine_prim("%COPY-STRUCT",        S, xcpystruct        ); /* 288 */
Xxldefine_prim("%STRUCT-REF",        S, xstrref        ); /* 289 */
Xxldefine_prim("%STRUCT-SET",        S, xstrset        ); /* 290 */
Xxldefine_prim("ASIN",            S, xasin        ); /* 291 */
Xxldefine_prim("ACOS",            S, xacos        ); /* 292 */
Xxldefine_prim("ATAN",            S, xatan        ); /* 293 */
X
X    /* extra table entries */
Xxldefine_prim("SYSTEM",            S, Prim_SYSTEM        ); /* 294 NPM */
Xxldefine_prim("POPEN",            S, Prim_POPEN        ); /* 295 NPM */
Xxldefine_prim("PCLOSE",            S, Prim_PCLOSE        ); /* 296 NPM */
Xxldefine_prim("FSCANF-FIXNUM",        S, Prim_FSCANF_FIXNUM    ); /* 297 NPM */
Xxldefine_prim("FSCANF-STRING",        S, Prim_FSCANF_STRING    ); /* 298 NPM */
Xxldefine_prim("FSCANF-FLONUM",        S, Prim_FSCANF_FLONUM    ); /* 299 NPM */
Xxldefine_prim("COPY-ARRAY",        S, Prim_COPY_ARRAY    ); /* 300 NPM */
Xxldefine_prim("ARRAY-INSERT-POS",    S, Prim_ARRAY_INSERT_POS); /* 301 NPM */
Xxldefine_prim("ARRAY-DELETE-POS",    S, Prim_ARRAY_DELETE_POS); /* 302 NPM */
X
X    /* include system dependant function pointers */
X#include "osptrs.h"
X
X/* Include hybrid-class funtab entries: */  /* JSP a la Voodoo */
X#define MODULE_XLFTAB_C_FUNTAB_S
X#include "../../xmodules.h"
X#undef MODULE_XLFTAB_C_FUNTAB_S
X
X/* Include hybrid-class funtab entries: */  /* JSP a la Voodoo */
X#define MODULE_XLFTAB_C_FUNTAB_F
X#include "../../xmodules.h"
X#undef MODULE_XLFTAB_C_FUNTAB_F
X
X}
END_OF_FILE
if test 22885 -ne `wc -c <'src/xlisp/xcore/c/xlftab.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlftab.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlftab.c'
fi
echo shar: End of archive 10 \(of 16\).
cp /dev/null ark10isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 16 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0